home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Caml Light 0.7 / examples / asl / semant.ml < prev    next >
Encoding:
Text File  |  1995-06-01  |  2.0 KB  |  63 lines  |  [TEXT/MPS ]
  1. (* $Id: semant.ml,v 1.5 1995/02/08 18:57:22 xleroy Exp $ *)
  2.  
  3. #open "parser";;
  4.  
  5. type semval = Numval of int
  6.             | Funval of (semval -> semval);;
  7. exception Illtyped;;
  8. exception SemantBug of string;;
  9. let init_semantics caml_fun =
  10.     Funval
  11.       (function Numval n ->
  12.          Funval(function Numval m -> Numval(caml_fun n m)
  13.                         | _ -> raise Illtyped)
  14.               | _ -> raise Illtyped);;
  15. let caml_function = function
  16.     "+" -> prefix +
  17.   | "-" -> prefix -
  18.   | "*" -> prefix *
  19.   | "/" -> prefix /
  20.   | "=" -> (fun n m -> if n=m then 1 else 0)
  21.   | s -> raise (SemantBug "Unknown primitive");;
  22. let init_sem =  map (fun x -> init_semantics(caml_function x))
  23.                     init_env;;
  24. let global_sem = ref init_sem;;
  25. let rec nth n = function
  26.      []  -> raise (Failure "nth")
  27.   | x::l -> if n=1 then x else nth (n-1) l;;
  28. let rec semant rho = sem
  29.     where rec sem = function
  30.       Const n -> Numval n
  31.     | Var(n) -> nth n rho
  32.     | Cond(e1,e2,e3) ->
  33.         (match sem e1 with Numval 0 -> sem e3
  34.                          | Numval n -> sem e2
  35.                          | _ -> raise Illtyped)
  36.     | Abs(_,e') -> Funval(fun x -> semant (x::rho) e')
  37.     | App(e1,e2) -> (match sem e1
  38.                       with Funval(f) -> f (sem e2)
  39.                          | _ -> raise Illtyped)
  40. ;;
  41.  
  42. let semant_asl = function Decl(s,e) ->
  43.   semant !global_sem e
  44. ;;
  45.  
  46. let print_semval = function
  47.   Numval n -> print_string "Numval "; print_int n
  48. | Funval f -> print_string "Funval <fun>"
  49. ;;
  50.  
  51. (*
  52. semantics (parse_top "f = \\x. + x 1;");;
  53. semantics (parse_top "i = \\x. x;");;
  54. semantics (parse_top "x = i (f 2);");;
  55. semantics (parse_top "y = (C x (\\x.x) 2) 0;");;
  56. semantics (parse_top "z = \\f.((\\x.f(\\y.(x x) y))(\\x.f(\\y.(x x) y)));");;
  57. semantics (parse_top "f = z(\\f.(\\n. C (= n 0) 1 ( * n (f (- n 1)))));");;
  58. semantics (parse_top "x = f 8;");;
  59. semantics (parse_top
  60.   "b = z(\\b.(\\n. C (= n 1) 1 (C (= n 2) 1 (+ (b(- n 1)) (b(- n 2))))));");;
  61. semantics (parse_top "x = b 9;");;
  62. *)
  63.